home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / decl.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  20KB  |  609 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #define GEN
  11.  
  12. #include "hdr.h"
  13. #include "vars.h"
  14. #include "gvars.h"
  15. #include "ops.h"
  16. #include "setp.h"
  17. #include "maincasp.h"
  18. #include "miscp.h"
  19. #include "smiscp.h"
  20. #include "segment.h"
  21. #include "genp.h"
  22. #include "typep.h"
  23. #include "statp.h"
  24. #include "segmentp.h"
  25. #include "exprp.h"
  26. #include "gmiscp.h"
  27. #include "gutilp.h"
  28. #include "axqrp.h"
  29. #include "declp.h"
  30.  
  31. static void gen_structured_object(Node, Symbol, int);
  32.  
  33. void create_object(Tuple id_list_arg, Symbol type_name, Node init_node,
  34.   int obj_is_constant)                                         /*;create_object*/
  35. {
  36.     /*
  37.      * This procedure is used to create objects (const or var).
  38.      * id_list is a list (tuple) of name nodes of objects to be created.
  39.      * The initialization part cannot have side effect, unless id_list
  40.      * contains a single element (transformation by expander)
  41.      *
  42.      * In order to generate not too bad a code, this procedure is organized
  43.      * as a gigantic if ... elseif ... elseif... structure, checking for the
  44.      * different configurations. Optimizations may still be added.
  45.      *
  46.      * The following cases are considered:
  47.      *
  48.      *       1/ Size of object and initial value are known statically.
  49.      *             a/ Global object or local constant (promoted to global)
  50.      *                with static initial value.
  51.      *             b/ Global object initialized with dynamic value.
  52.      *                Static part is initialized in data segment.
  53.      *             c/ Uninitialized global object (variable or deferred
  54.      *                constant).
  55.      *             d/ Local constant initialized with dynamic value,
  56.      *                deferred constant, or local variable.
  57.      *              
  58.      *       2/ Size of object is not known statically
  59.      *             a/ Global object with variable size (transformed into
  60.      *                renaming).
  61.      *             b/ Local array or record with variable size.
  62.      *
  63.      */
  64.  
  65.     Node        node, id, first_id, last_id, init_call_node, pre_node;
  66.     Symbol    first_name, obj_name;
  67.     int        obj_is_global, ikind, i, n;
  68.     Fortup    ft1;
  69.     Segment    init_val;    /* type should be Ivalue */
  70.     Node        dyn_node;
  71.     Symbol    model_name, subtype;
  72.     Tuple    tup, id_list;
  73.     Const    ival, small_const;
  74.     int          special_aggregate;
  75.  
  76.     /* id_list_arg needed since id_list used desctructively  6-25-85 */
  77.     id_list = tup_copy(id_list_arg);
  78. #ifdef TRACE
  79.     if (debug_flag) {
  80.         /*gen_trace("CREATE_OBJECT", id_list);*/
  81.         gen_trace("CREATE_OBJECT");
  82.         FORTUP(node = (Node), id_list, ft1);
  83.             gen_trace_node("  CREATE_OBJECT argument", node);
  84.         ENDFORTUP(ft1);
  85.     }
  86. #endif
  87.     init_val = (Segment)0; /* indicate not yet defined */
  88.     obj_is_global = CURRENT_LEVEL == 1;
  89.     if (N_KIND(init_node) == as_init_call) {
  90.         /* Initialization procedure call */
  91.         init_call_node = init_node;
  92.         init_node      = OPT_NODE;
  93.     }
  94.     else {
  95.         init_call_node = OPT_NODE;
  96.     }
  97.  
  98.     while (N_KIND(init_node) == as_insert) {
  99.         FORTUP(pre_node = (Node), N_LIST(init_node), ft1);
  100.             compile(pre_node);
  101.         ENDFORTUP(ft1);
  102.         init_node = N_AST1(init_node);
  103.     }
  104.  
  105.     if (N_KIND(init_node) == as_raise) {
  106.         /* Simplest case, indeed. */
  107.         compile(init_node);
  108.         init_node = OPT_NODE;
  109.     }
  110.  
  111.     if (has_static_size(type_name) && !(is_array_type(type_name)
  112.       &&is_unconstrained(type_name))
  113.       && (init_node == OPT_NODE ||has_static_size(get_type(init_node)))) {
  114.         /*
  115.          * 1- Size of object is known statically(and also size of initial value)
  116.          * -------------------------------------
  117.          */
  118.         if ((obj_is_global || obj_is_constant) && is_ivalue(init_node)) {
  119.             /*
  120.              *         1a- Global object or local const (promoted to global)
  121.              *             with static initial value.
  122.              *             Generate objects in data seg initialized with value
  123.              *             Generate only one object for multiple constants.
  124.              */
  125.             if (is_fixed_type(type_name)) {
  126.                 init_val = segment_new(SEGMENT_KIND_DATA, 1);
  127.                 small_const = small_of(base_type(type_name));
  128.                 segment_put_long(init_val , rat_tof(get_ivalue(init_node),
  129.                   small_const, size_of(type_name) ));
  130.             }
  131.             else if (is_simple_type(type_name)) {
  132.                 ival = get_ivalue(init_node);
  133.                 ikind = ival->const_kind;
  134.                 if(ikind == CONST_INT) {
  135.                     init_val = segment_new(SEGMENT_KIND_DATA, 1);
  136.                     segment_put_word(init_val, ival->const_value.const_int);
  137.                 }
  138.                 else if(ikind == CONST_REAL) {
  139.                     init_val = segment_new(SEGMENT_KIND_DATA, 1);
  140.                     segment_put_real(init_val, ival->const_value.const_real);
  141.                 }
  142.                 else {
  143. #ifdef DEBUG
  144.                     printf("const_kind %d\n", ikind);
  145. #endif        
  146.                     chaos("create_object:unsupported kind");
  147.                 }
  148.             }
  149.             else if (is_array_type(type_name)) {
  150.                 /* build the appropriate vector... */
  151.                 init_val = array_ivalue(init_node);
  152.             }
  153.             else if (is_record_type(type_name)) {
  154.                 init_val = record_ivalue(init_node);
  155.             }
  156.             else {
  157.                 compiler_error_k("Unknown type for constant ", init_node);
  158.                 return;
  159.             }
  160.             if (obj_is_constant) {
  161.                 first_name = get_constant_name(init_val);
  162.                 FORTUP(id = (Node), id_list, ft1);
  163.                     obj_name = N_UNQ(id);
  164.                     assign_same_reference(obj_name, first_name);
  165.                 ENDFORTUP(ft1);
  166.             }
  167.             else {
  168.                 FORTUP(id = (Node), id_list, ft1);
  169.                     obj_name = N_UNQ(id);
  170.                     next_global_reference_segment(obj_name, init_val);
  171.                 ENDFORTUP(ft1);
  172.             }
  173.         }
  174.         else if (obj_is_global && init_node != OPT_NODE) {
  175.             /*
  176.              *          1b- Global object initialized with dynamic value
  177.              *              Generate first object in data seg with static part
  178.              *              initialized, compile code to initialize the rest,
  179.              *              then assign first object to others
  180.              */
  181.             if (N_KIND(init_node) == as_array_aggregate) {
  182.                 init_val = array_ivalue(init_node);
  183.             }
  184.             else if (N_KIND(init_node) == as_record_aggregate) {
  185.                 init_val = record_ivalue(init_node);
  186.             }
  187.             else {
  188.                 /* TBSL: review translation from SETL */
  189.                 /* build segment of desired length, initially all zero */
  190.                 n = size_of(type_name);
  191.                 init_val = segment_new(SEGMENT_KIND_DATA, n);
  192.                 for (i = 1; i <= n; i++) {
  193.                     segment_put_word(init_val, 0);
  194.                 }
  195.             }
  196.             FORTUP(id = (Node), id_list, ft1);
  197.                 obj_name = N_UNQ(id);
  198.                 next_global_reference_segment(obj_name, init_val);
  199.             ENDFORTUP(ft1);
  200.  
  201.             if (is_simple_type(type_name)) {
  202.                 gen_value(init_node);
  203.                 last_id = (Node) tup_frome(id_list);
  204.                 FORTUP(id = (Node), id_list, ft1);
  205.                     id = (Node) tup_fromb(id_list);
  206.                     obj_name = (Symbol) N_UNQ(id);
  207.                     gen_k(I_DUPLICATE, kind_of(type_name));
  208.                     gen_ks(I_POP, kind_of(type_name), obj_name);
  209.                 ENDFORTUP(ft1);
  210.                 obj_name = N_UNQ(last_id);
  211.                 gen_ks(I_POP, kind_of(type_name), obj_name);
  212.             }
  213.             else {
  214.                 first_id = (Node) tup_fromb(id_list);
  215.                 if (is_aggregate(init_node)) {
  216.                     init_node = N_AST2(N_AST1(init_node));
  217.                     compile(init_node);
  218.                 }
  219.                 else {
  220.                     select_assign(first_id, init_node, type_name);
  221.                 }
  222.                 FORTUP(id = (Node), id_list, ft1);
  223.                     select_assign(id, first_id, type_name);
  224.                 ENDFORTUP(ft1);
  225.             }
  226.         }
  227.         else if (obj_is_global) {
  228.             /*
  229.              *         1c- Uninitialized global object (Variable or deferred
  230.              *             constant)
  231.              *             Generate objects in data segment. If initialization
  232.              *             procedure, call it on first object, then assign first
  233.              *             object to others.
  234.              */
  235.             /* build a segment, initially all zeros, of desired length */
  236.             n = size_of(type_name);
  237.             /*
  238.              * this is a kludge for deferred const EMPTY in VAR_STRING package.
  239.              */
  240.             if (n== 0) n = 3;
  241.             init_val = segment_new(SEGMENT_KIND_DATA, n);
  242.             for (i = 1; i <= n; i++)
  243.                 segment_put_word(init_val, 0);
  244.             FORTUP(id = (Node), id_list, ft1);
  245.                 obj_name = N_UNQ(id);
  246.                 next_global_reference_segment(obj_name, init_val);
  247.             ENDFORTUP(ft1);
  248.             if (init_call_node != OPT_NODE ) {
  249.                 compile(init_call_node);     /* This initializes 1st object */
  250.                 first_id = (Node) tup_fromb(id_list);
  251.                 FORTUP(id = (Node), id_list, ft1); /* Assign it to other objs */
  252.                 select_assign(id, first_id, type_name);
  253.                 ENDFORTUP(ft1);
  254.             }
  255.         }
  256.         else {
  257.             /*
  258.              *     1d- Local constant initialized with dynamic value, deferred
  259.              *         constant, or local variable, initialized or not.
  260.              *         Create local references. If no initialization (implicit
  261.              *         or explicit) create objects, otherwise create and
  262.              *         initialize first objects, and create copies for others.
  263.              */
  264.             FORTUP(id = (Node), id_list, ft1);
  265.                 next_local_reference(N_UNQ(id));
  266.             ENDFORTUP(ft1);
  267.             if (is_simple_type(type_name)) {
  268.                 if (init_node != OPT_NODE) {
  269.                     gen_value(init_node);
  270.                     last_id = (Node) tup_frome(id_list);
  271.                     FORTUP(id = (Node), id_list, ft1);
  272.                         gen_k(I_DUPLICATE, kind_of(type_name));
  273.                         gen_k(I_CREATE_COPY, kind_of(type_name));
  274.                         gen_s(I_UPDATE_AND_DISCARD, N_UNQ(id));
  275.                     ENDFORTUP(ft1);
  276.                     gen_k(I_CREATE_COPY, kind_of(type_name));
  277.                     gen_s(I_UPDATE_AND_DISCARD, N_UNQ(last_id));
  278.                 }
  279.                 else{
  280.                     FORTUP(id = (Node), id_list, ft1);
  281.                         gen_ks(I_DECLARE, kind_of(type_name), N_UNQ(id));
  282.                     ENDFORTUP(ft1);
  283.                 }
  284.             }
  285.             else {  /* Array or record */
  286.                 if (!local_reference_map_defined(type_name)
  287.                   && is_constant (N_UNQ ((Node) set_arb (id_list)))
  288.                   && S_SEGMENT(type_name) == -1) {
  289.                     /* deferred constant: type not elaborated yet */
  290.                     return;
  291.                 }
  292.                 if (init_node != OPT_NODE) {
  293.                     first_id = (Node) tup_fromb(id_list);
  294.                     first_name  = N_UNQ(first_id);
  295.                     if (is_aggregate(init_node)) {
  296.                         /*
  297.                          * Create a static model containing the static part if
  298.                          * there is one, then create a copy and initialize
  299.                          * dynamic part in the copy. Note: the name of the
  300.                          * aggregate is already first_name.
  301.                          */
  302.                         /*stat_node=N_AST1(init_node); -- not used   ds 7-8-85*/
  303.                         dyn_node = N_AST2(N_AST1(init_node));
  304.                         /*nam_node=N_AST3(init_node); -- not used   ds 7-8-85*/
  305.                         model_name   = new_unique_name("static_");
  306.                         special_aggregate = FALSE;
  307.                         /* A special aggregate is an array aggregate whose
  308.                          * unique name is not defined.  In this case we have
  309.                          * to compile the initialization part of the
  310.                          * aggregate first : the assignements refer to
  311.                          * model_name 
  312.                          * This situation occurs when we have an aggregate with
  313.                          * a qualification that appears as an initiliazation of
  314.                          * an object. Expand_decl cannot execute the code that
  315.                          * deals with an aggregate. The qualification is
  316.                          * removed by the expander and therefore the init part
  317.                          * is just an aggregate. But the work in expand_decl
  318.                          * has not be performed...
  319.                          */
  320.                         if (is_array_type(type_name)) {
  321.                             if (!is_defined (N_UNQ (init_node))) {
  322.                                 special_aggregate = TRUE;
  323.                                 model_name   = N_UNQ (init_node); 
  324.                             }
  325.                             next_global_reference_template(model_name,
  326.                               array_ivalue(init_node));
  327.                         }
  328.                         else {
  329.                             next_global_reference_template(model_name,
  330.                               record_ivalue(init_node));
  331.                         }
  332.                         if (special_aggregate)
  333.                             compile(dyn_node); 
  334.                         gen_s(I_PUSH_EFFECTIVE_ADDRESS, model_name);
  335.                         gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  336.                         gen(I_CREATE_COPY_STRUC);
  337.                         if (is_array_type(type_name))
  338.                             gen_ks(I_DISCARD_ADDR, 1, type_name);
  339.                         gen_s(I_UPDATE_AND_DISCARD, first_name);
  340.                         if (! special_aggregate)
  341.                             compile(dyn_node);
  342.                     }
  343.                     else {
  344.                         gen_structured_object(init_node, type_name,
  345.                           obj_is_constant);
  346.                         if (is_array_type(type_name))
  347.                             gen_ks(I_DISCARD_ADDR, 1, type_name);
  348.                         gen_s(I_UPDATE_AND_DISCARD, first_name);
  349.                     }
  350.  
  351.                     if (tup_size(id_list)) {
  352.                         gen_s(I_PUSH_EFFECTIVE_ADDRESS, first_name);
  353.                         FORTUP(id = (Node), id_list, ft1);
  354.                             gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  355.                             gen(I_CREATE_COPY_STRUC);
  356.                             if (is_array_type(type_name)) /* remove type */
  357.                                 gen_ks(I_DISCARD_ADDR, 1, type_name);
  358.                             gen_s(I_UPDATE, N_UNQ(id));
  359.                         ENDFORTUP(ft1);
  360.                         gen_ks(I_DISCARD_ADDR, 1, 
  361.                           N_UNQ((Node) id_list[tup_size(id_list)]));
  362.                     }
  363.                 }
  364.                 else if (init_call_node != OPT_NODE ) {
  365.                     gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  366.                     first_id = (Node) tup_fromb(id_list);
  367.                     first_name  = N_UNQ(first_id);
  368.                     gen(I_CREATE_STRUC);
  369.                     if (is_array_type(type_name))
  370.                         gen_ks(I_DISCARD_ADDR, 1, type_name);
  371.                     gen_s(I_UPDATE_AND_DISCARD, first_name);
  372.                     compile(init_call_node);  /* First object now initialized */
  373.  
  374.                     if (tup_size(id_list)) {
  375.                         gen_s(I_PUSH_EFFECTIVE_ADDRESS, first_name);
  376.                         FORTUP(id = (Node), id_list, ft1);
  377.                             gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  378.                             gen(I_CREATE_COPY_STRUC);
  379.                             if (is_array_type(type_name)) /* remove type */
  380.                                 gen_ks(I_DISCARD_ADDR, 1, type_name);
  381.                             gen_s(I_UPDATE, N_UNQ(id));
  382.                         ENDFORTUP(ft1);
  383.                         gen_ks(I_DISCARD_ADDR, 1,
  384.                           N_UNQ((Node)id_list[tup_size(id_list)]));
  385.                     }
  386.                 }
  387.                 else { /* Absolutely no initialization */
  388.                     gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  389.                     last_id = (Node) tup_frome(id_list);
  390.                     FORTUP(id = (Node), id_list, ft1);
  391.                         obj_name = N_UNQ(id);
  392.                         gen_k(I_DUPLICATE, mu_addr);
  393.                         gen(I_CREATE_STRUC);
  394.                         if (is_array_type(type_name))
  395.                             gen_ks(I_DISCARD_ADDR, 1, type_name);
  396.                         gen_s(I_UPDATE_AND_DISCARD, obj_name);
  397.                     ENDFORTUP(ft1);
  398.                     obj_name = N_UNQ(last_id);
  399.                     gen(I_CREATE_STRUC);
  400.                     if (is_array_type(type_name))
  401.                         gen_ks(I_DISCARD_ADDR, 1, type_name);
  402.                     gen_s(I_UPDATE_AND_DISCARD, obj_name);
  403.                 }
  404.             }
  405.         }
  406.         /* 2- Size of object is not known statically
  407.          * -----------------------------------------
  408.          * Also some pathological cases where size of initial value is not known
  409.          * although size of object is known: V: constrained_type := (F..G => 0);
  410.          * No use in optimizing that case: Only JBG can write that.
  411.          */
  412.     }
  413.     else if (obj_is_global) {
  414.         /*    2a- Global object
  415.          *          Variable size => transformed into renaming
  416.          *          If initialization, initialize first object and then create
  417.          *          copies.
  418.          */
  419.         if (init_node != OPT_NODE) { /* Explicit initialization */
  420.             first_id = (Node) tup_fromb(id_list);
  421.             obj_name = N_UNQ(first_id);
  422.             next_global_reference_z(obj_name);
  423. #ifdef TBSL
  424.             ALIAS(obj_name) = new_unique_name("dyn_global"); /*not used */
  425. #endif
  426.             gen_structured_object(init_node, type_name, obj_is_constant);
  427.             if (is_array_type(type_name) && is_unconstrained(type_name)) {
  428.                 /*       Completely dynamic unconstrained constant.
  429.                  *          Ex: X: constant STRING := F(..) & V;
  430.                  */
  431.                 subtype = new_unique_name("typeof_");
  432.                 next_global_reference_z(subtype);
  433.  
  434.                 /* Note: no index type list can be given... */
  435.                 tup = tup_new(2);
  436.                 tup[1] = (char *) tup_new1((char *) symbol_none);
  437.                 tup[2] = (char *) COMPONENT_TYPE(type_name);
  438.                 new_symbol(subtype, na_subtype, type_name,
  439.                   tup, root_type(type_name));
  440.                 TYPE_OF(obj_name) = subtype;
  441.                 type_name         = subtype;     /* To be used by other obj. */
  442.                 gen_ks(I_POP, mu_addr, subtype);
  443.                 gen_ks(I_PUSH, mu_addr, subtype);
  444.             }
  445.             if (is_record_type(type_name)) {
  446.                 /* May be useless, but the peep-hole will take care of it */
  447.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  448.             }
  449.  
  450.             FORTUP(id = (Node), id_list, ft1);
  451.                 gen_k(I_DUPLICATE, mu_dble);
  452.                 gen(I_CREATE_COPY_STRUC);
  453.                 if (is_array_type(type_name))
  454.                     gen_ks(I_DISCARD_ADDR, 1, type_name);
  455.                 gen_ks(I_POP, mu_addr, obj_name);
  456.                 first_id         = id;
  457.                 obj_name         = N_UNQ(first_id);
  458.                 TYPE_OF(obj_name) = type_name;    /* May have been changed. */
  459. #ifdef TBSL
  460.                 ALIAS (obj_name) = new_unique_name("dyn_global"); /*not used */
  461. #endif
  462.             ENDFORTUP(ft1);
  463.             gen_ks(I_DISCARD_ADDR, 1, type_name);
  464.             gen_ks(I_POP, mu_addr, obj_name);
  465.         }
  466.         else if (init_call_node != OPT_NODE) { /* Implicit initialization */
  467.             first_id = (Node) tup_fromb(id_list);
  468.             first_name   = N_UNQ(first_id);
  469.             next_global_reference_z(first_name);
  470. #ifdef TBSL
  471.             ALIAS(first_name) = new_unique_name("dyn_global"); /*not used */
  472. #endif
  473.             gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  474.             gen(I_CREATE_STRUC);
  475.             gen_ks(I_POP, mu_addr, first_name);
  476.             compile(init_call_node);      /* first object now initialized */
  477.  
  478.             FORTUP(id = (Node), id_list, ft1);
  479.                 obj_name = N_UNQ(id);
  480.                 next_global_reference_z(obj_name);
  481.                 gen_ks(I_PUSH, mu_addr, first_name);
  482.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  483.                 gen(I_CREATE_COPY_STRUC);
  484.                 if (is_array_type(type_name))
  485.                     gen_ks(I_DISCARD_ADDR, 1, type_name);
  486.                 gen_ks(I_POP, mu_addr, obj_name);
  487. #ifdef TBSL
  488.                 ALIAS(obj_name) = new_unique_name("dyn_global"); /*not used */
  489. #endif
  490.             ENDFORTUP(ft1);
  491.         }
  492.         else { /* No initialization */
  493.             last_id = (Node) tup_frome(id_list);
  494.             gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  495.             FORTUP(id = (Node), id_list, ft1);
  496.                 obj_name = N_UNQ(id);
  497.                 next_global_reference_z(obj_name);
  498.                 gen_k(I_DUPLICATE, mu_addr);
  499.                 gen(I_CREATE_STRUC);
  500.                 gen_ks(I_POP, mu_addr, obj_name);
  501. #ifdef TBSL
  502.                 ALIAS(obj_name) = new_unique_name("dyn_global"); /*not used */
  503. #endif
  504.             ENDFORTUP(ft1);
  505.             obj_name = N_UNQ(last_id);
  506.             next_global_reference_z(obj_name);
  507.             gen(I_CREATE_STRUC);
  508.             gen_ks(I_POP, mu_addr, obj_name);
  509. #ifdef TBSL
  510.             ALIAS(obj_name) = new_unique_name("dyn_global"); /*not used */
  511. #endif
  512.         }
  513.     }
  514.     else {
  515.         /*    2b- Local array or record, variable size
  516.          *          Create local reference and object.
  517.          *      TBSL optimization
  518.          */
  519.         FORTUP(id = (Node), id_list, ft1);
  520.             obj_name = N_UNQ(id);
  521.             next_local_reference(obj_name);
  522.             if (init_node != OPT_NODE) {
  523.                 gen_structured_object(init_node, type_name, obj_is_constant);
  524.                 if (is_array_type(type_name) && is_unconstrained(type_name)) {
  525.                     /*
  526.                      *         Completely dynamic unconstrained constant.
  527.                      *           Ex: X: constant STRING := F(..) & V;
  528.                      */
  529.                     subtype = new_unique_name("typeof_");
  530.                     next_local_reference(subtype);
  531.  
  532.                     /*  Note: no index type list can be given...  */
  533.  
  534.                     tup = tup_new(2);
  535.                     tup[1] = (char *) tup_new1((char *) symbol_none);
  536.  
  537.                     tup[2] = (char *) COMPONENT_TYPE(type_name);
  538.                     new_symbol(subtype, na_subtype, type_name,
  539.                       tup, root_type(type_name));
  540.                     TYPE_SIZE(subtype) = -1;
  541.                     TYPE_OF(obj_name)  = subtype;
  542.                     gen_s(I_UPDATE, subtype);
  543.                     type_name = subtype;
  544.                 }
  545.             }
  546.             else {
  547.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  548.                 gen(I_CREATE_STRUC);
  549.             }
  550.             if (is_array_type(type_name))
  551.                 gen_ks(I_DISCARD_ADDR, 1, type_name);
  552.             gen_s(I_UPDATE_AND_DISCARD, obj_name);
  553.             if (init_call_node != OPT_NODE) {
  554.                 compile(init_call_node);
  555.                 /*  This first object will now serve as initial value for
  556.                  *    other objects
  557.                  */
  558.                 init_node      = id;
  559.                 init_call_node = OPT_NODE;
  560.             }
  561.         ENDFORTUP(ft1);
  562.     }
  563.  
  564. }
  565.  
  566. static void gen_structured_object(Node init_node, Symbol type_name,
  567.   int obj_is_constant)                             /*;gen_structured_object*/
  568. {
  569.     /*
  570.      * This procedure is used in place of GEN_VALUE when it is necessary to
  571.      * generate a new object, i.e. making a copy in cases where GEN_VALUE may
  572.      * generate the address of an already existing object.
  573.      */
  574.  
  575.     Node    expr_node;
  576.     Symbol    expr_type;
  577.     int        needs_copy, constrained_obj, val_is_constant, constrained_val;
  578.  
  579.     expr_node = init_node;
  580.     expr_type = get_type(init_node);
  581.  
  582.     while (N_KIND(expr_node) == as_qual_discr
  583.       ||   N_KIND(expr_node) == as_qual_index
  584.       ||   N_KIND(expr_node) == as_qual_sub) {
  585.         expr_node = N_AST1(expr_node);
  586.     }
  587.     needs_copy = is_object(expr_node) | is_ivalue(expr_node);
  588.  
  589.     gen_value(init_node);
  590.  
  591.     if (needs_copy) {
  592.         if (is_record_type(expr_type))
  593.             gen_s(I_PUSH_EFFECTIVE_ADDRESS, expr_type);
  594.         gen(I_CREATE_COPY_STRUC);
  595.     }
  596.     if (is_record_type(type_name) ) {/* May need to adjust constrained */
  597.         constrained_obj = ! is_unconstrained(type_name) || obj_is_constant;
  598.         val_is_constant = is_simple_name(expr_node) &&
  599.           (NATURE(N_UNQ(expr_node)) == na_constant);
  600.         constrained_val = ! is_unconstrained(expr_type) || val_is_constant;
  601.         if (constrained_obj != constrained_val) {
  602.             gen_k(I_DUPLICATE, mu_addr);
  603.             gen_kic(I_PUSH_IMMEDIATE, kind_of(symbol_boolean), 
  604.               constrained_obj, "constrained bit");
  605.             gen_k(I_MOVE, kind_of(symbol_boolean));
  606.         }
  607.     }
  608. }
  609.